home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-04 / aie8911.zip / LIB.ARI < prev    next >
Text File  |  1989-08-27  |  32KB  |  844 lines
  1.  
  2.  
  3.  
  4. %%%%%%%%%% end prepcomp generated declarations %%%%%%%%%%%%%%%%%%%%
  5.  
  6.  
  7. % :- module lib.
  8.  
  9. :- visible write_error/1.
  10. /*************************************************************************/
  11. /***************** member : set membership  ******************************/
  12. /*************************************************************************/
  13.  
  14. % Note : this does not backtrack
  15.  
  16. /* member( X, L ) succeeds if X is a member of list L */
  17. member( X, [ X | _ ] ) :- !.           /*  If X is the first element of  */
  18.                                        /*  a set then member is true     */
  19. member( X, [ _ | T ] ) :- member( X, T ).
  20.                                        /*  Otherwise, membership         */
  21.                                        /*  depends on the tail of the    */
  22.                                        /*  list.                         */
  23.  
  24.  
  25. /*************************************************************************/
  26. /***************** memb : backtracing version of member ******************/
  27. /*************************************************************************/
  28.  
  29. memb( X, [ X | Y ] ).
  30. memb( X, [ Y | Z ] ) :- memb( X, Z ).
  31.  
  32. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  33.  
  34.  
  35. minimum( [],        0 )  :-  !.
  36. minimum( [ M ],     M )  :-  !.
  37. minimum( [ M, K ], M )  :-  M =< K, ! .
  38. minimum( [ M | R ], N )  :-  minimum( R, K ),
  39.                              minimum( [ K, M ], N ).
  40.  
  41.  
  42. maximum( [],        0 )  :-  !.
  43. maximum( [ M ],     M )  :-  !.
  44. maximum( [ M, K ],  M )  :-  M >= K,  !.
  45. maximum( [ M | R ], N )  :-  maximum( R, K ), maximum( [ K, M ], N ).
  46.  
  47. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  48. %%%%%%% append : appends lists %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  49. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  50.  
  51. /*
  52. Note: Original academic version changed.
  53.       backtracking eliminated with the cut.
  54.       The loss of generality usually does not matter,
  55.       but the backtracking can lead to weird behaviour in a fail loop,
  56.       for example.
  57. */
  58.  
  59. append( [], X, X ) :- !.
  60. append( [ X | Y ], Z, [ X | W ] ) :- append( Y, Z, W ).
  61.  
  62.  
  63. /*************************************************************************/
  64. /************** lc_char : converts char. to lower case *******************/
  65. /*************************************************************************/
  66.  
  67. lc_char( In, Out ) :-
  68.      is_uc( In ), !, Out is In + 32.
  69. lc_char( In, In ).
  70.  
  71.  
  72. /*************************************************************************/
  73. /************** lc_char : converts char. to lower case *******************/
  74. /*************************************************************************/
  75.  
  76. lc_char( In, Out ) :-
  77.      is_uc( In ), !, Out is In + 32.
  78. lc_char( In, In ).
  79.  
  80.  
  81. /*************************************************************************/
  82. /***************  is_list : is arg. a list *******************************/
  83. /*************************************************************************/
  84.  
  85. is_list( [] ) .
  86. is_list( [_ | _ ] ) .
  87.  
  88. /*************************************************************************/
  89. /***************  union : union of sets   ********************************/
  90. /*************************************************************************/
  91.  
  92. /* union computes the union of two sets */
  93. union( [], B, B ) :- !.                /*  union of an empty set with    */
  94.                                        /*  set                           */
  95.                                        /*  set B is B                    */
  96. union( [ H | T ], B, U ) :-            /*  union of a set with head H    */
  97.                                        /*  and                           */
  98.                                        /*  a set B, with result going    */
  99.                                        /*  into                          */
  100.                                        /*  U                             */
  101.     member( H, B ),                    /*  If H is already in B          */
  102.     union( T, B, U ), !.               /*  union B with the tail of      */
  103.                                        /*  first set                     */
  104. union( [ H | T ], B, [ H | U ] ) :-    /*  If H is not in B, add it as   */
  105.                                        /*  the head                      */
  106.     union( T, B, U ), !.               /*  of the union set, and make    */
  107.                                        /*  the tail                      */
  108.                                        /*  of the union the union of     */
  109.                                        /*  the tail of                   */
  110.                                        /*  the first set and B           */
  111.  
  112.  
  113.  
  114. /*************************************************************************/
  115. /***************  blank_line : succeed for line with nothing on it *******/
  116. /*************************************************************************/
  117.  
  118. blank_line( Line) :-
  119.      string_length( Line, 0),
  120.        file_trace($blank line found$),
  121.      !.
  122.  
  123. blank_line( Line) :-
  124.      list_text( List, Line),
  125.      blanks_list( List),
  126.      file_trace([$blank line in chars : $, List]).
  127.  
  128. blanks_list([]) :- !,
  129.        file_trace($blank line found$).
  130. blanks_list([H|T]) :-
  131.      is_separator(H), !,
  132.      blanks_list(T).
  133.  
  134.  
  135.  
  136.  
  137. /*************************************************************************/
  138. /***************  reverse : reverses a list    ***************************/
  139. /*************************************************************************/
  140.  
  141. /* reverse( List, Reverse ) reverses a list, putting the reverse of List in
  142.    Reverse */
  143. reverse( List, Reverse ) :- reverse1( List, [], Reverse ).
  144. /* reverse uses reverse1( ToDo, SoFar, NextStep ) , where,
  145.     ToDo = the tail of the input list that still needs to be
  146.            reversed,
  147.     SoFar = The part of the reversed list built so far,
  148.     NextStep = the complete reversed list                          */
  149. reverse1( [], Result, Result ).        /*  If ToDo is empty, return      */
  150.                                        /*  SoFar                         */
  151.                                        /*  which contains reversed list  */
  152. reverse1( [ H | T ], SoFar, Result ) :-
  153.                                        /*  If ToDo is non-empty          */
  154.     reverse1( T, [ H | SoFar ], Result ).
  155.                                        /*  move the head element of      */
  156.                                        /*  ToDo                          */
  157.                                        /* to So_far ( note that later
  158.                                           elements of ToDo are put by later
  159.                                           calls to reverse1 BEFORE the
  160.                                           current head ). Then apply reverse1
  161.                                           to the tail of the current list. */
  162.  
  163.  
  164.  
  165. /**************** strip_off_extra_blanks *********************************/
  166. /*
  167. Call:
  168.  
  169.     strip_off_extra_blanks(In_string, Out_string)
  170.  
  171. Input args:
  172.  
  173.       In_string = a string
  174.  
  175. Output args:
  176.  
  177.       Out_string = In_string with leading and trailing blanks stripped off
  178.  
  179. Success conditions : always_succeeds
  180.  
  181. */
  182.  
  183. strip_off_extra_blanks(In_string, Out_string) :-
  184.       string( In_string ),!,
  185.       strip_off_initial_blanks(In_string,  Temp),!,
  186.       strip_off_trailing_blanks( Temp , Out_string).
  187.  
  188. strip_off_extra_blanks(In_string, Out_string) :-
  189.       convert_to_string( In_string, S_In_string),
  190.       strip_off_extra_blanks( S_In_string  , Out_string).
  191.  
  192. /**************** strip_off_trailing_blanks ******************************/
  193. /*
  194. Call:
  195.  
  196.     strip_off_trailing_blanks(In_string, Out_string)
  197.  
  198. Input args:
  199.  
  200.       In_string = a string
  201.  
  202. Output args:
  203.  
  204.       Out_string = In_string with trailing blanks stripped off
  205.  
  206. Success conditions : always_succeeds
  207.  
  208. */
  209. strip_off_trailing_blanks(In_string, Out_string)  :-
  210.       string( In_string ),!,
  211.       string_length( In_string , Lnth),!,
  212.       Pos is Lnth - 1,
  213.       strip_off_trailing_blanks_hlpr( In_string, Pos , Out_string).
  214.  
  215. strip_off_trailing_blanks(In_string, Out_string)  :-
  216.       convert_to_string( In_string, S_In_string), !,
  217.       strip_off_trailing_blanks(S_In_string, Out_string).
  218.  
  219. /**************** strip_off_trailing_blanks_hlpr **************************/
  220. /*
  221. Call:
  222.       strip_off_trailing_blanks_hlpr( In_string, Pos, Out_string)
  223.  
  224. Input args:
  225.  
  226.       In_string = a string
  227.  
  228.       Position = NEXT char position to be tested to see if it is a blank
  229.  
  230. Output args:
  231.  
  232.       Out_string = In_string with trailing blanks stripped off
  233.  
  234. Success conditions : always_succeeds
  235.  
  236. */
  237.  
  238. strip_off_trailing_blanks_hlpr( In_string, Pos, Out_string)  :-
  239.         Pos  < 0,!,
  240.         Out_string = $$.
  241.  
  242. strip_off_trailing_blanks_hlpr( In_string, Pos, Out_string)  :-
  243.            nth_char(Pos, In_string, Char),
  244.            is_separator( Char),!,
  245.            Pos1 is Pos - 1,
  246.            strip_off_trailing_blanks_hlpr( In_string, Pos1, Out_string).
  247.  
  248. strip_off_trailing_blanks_hlpr( In_string, Pos, Out_string)  :-
  249.            Lnth is Pos + 1,
  250.            substring(In_string, 0, Lnth, Out_string).
  251.  
  252.  
  253. /**************** strip_off_initial_blanks ********************************/
  254. /*
  255. Call:
  256.  
  257.     strip_off_initial_blanks(In_string, Out_string)
  258.  
  259. Input args:
  260.  
  261.       In_string = a string
  262.  
  263. Output args:
  264.  
  265.       Out_string = In_string with leading  blanks stripped off
  266.  
  267. Success conditions : always_succeeds
  268.  
  269. */
  270.  
  271. strip_off_initial_blanks(In_string, Out_string) :-
  272.       string( In_string ),!,
  273.       string_length( In_string , Lnth),!,
  274.       strip_off_initial_blanks_hlpr(0, In_string, Lnth, Out_string).
  275.  
  276. strip_off_initial_blanks(In_string, Out_string) :-
  277.       convert_to_string( In_string, S_In_string), !,
  278.       strip_off_initial_blanks(S_In_string, Out_string).
  279.  
  280.  
  281. /**************** strip_off_initial_blanks_hlpr ***************************/
  282. /*
  283. Call:
  284.  
  285.     strip_off_initial_blanks_hlpr(Position, In_string, Lnth, Out_string)
  286.  
  287. Input args:
  288.  
  289.       Position = NEXT char position to be tested to see if it is a blank
  290.  
  291.       In_string = a string
  292.  
  293.       Lnth = length of input string
  294.  
  295. Output args:
  296.  
  297.       Out_string = In_string with leading blanks stripped off
  298.  
  299. Success conditions : always_succeeds
  300.  
  301. */
  302. strip_off_initial_blanks_hlpr(Position, In_string, Lnth , Out_string) :-
  303.              Position >= Lnth,!,
  304.              Out_string = $$.
  305.  
  306. strip_off_initial_blanks_hlpr(Position, In_string, Lnth , Out_string) :-
  307.            nth_char(Position, In_string, Char),
  308.            is_separator( Char),!,
  309.            Position1 is Position +1,
  310.            strip_off_initial_blanks_hlpr(Position1,
  311.                                          In_string,
  312.                                          Lnth ,
  313.                                          Out_string).
  314.  
  315. strip_off_initial_blanks_hlpr(Position,
  316.                               In_string,
  317.                               Lnth ,
  318.                               Out_string) :-
  319.            Left_over_length is Lnth - Position,!,
  320.            substring(In_string, Position, Left_over_length , Out_string).
  321.  
  322.  
  323. /*************************************************************************/
  324. /*************** convert_to_string : converts data to string      ********/
  325. /*************************************************************************/
  326.  
  327. convert_to_string(X,X):-string(X),!.
  328.  
  329. convert_to_string(X,String):-
  330.    atom(X),!,atom_string(X,String).
  331.  
  332. convert_to_string(X,String):-
  333.    float(X),!,float_text(X,String,general).
  334.  
  335. convert_to_string(X,String):-
  336.    integer(X),!,int_text(X,String).
  337.  
  338. convert_to_string(X,String):-
  339.     var(X),!,
  340.     string_term(Y,X),
  341.     concat($Var$,Y,String).
  342.  
  343. convert_to_string([],$[]$):-!.
  344.  
  345. convert_to_string([H|T],String):-
  346.      convert_to_strings([H|T],L1),
  347.      put_in_commas(L1,L2),
  348.      concat(L2,S3),
  349.      concat([$[$,S3,$]$],String),!.
  350.  
  351. convert_to_string(X,String):-
  352.        X=..[Functor|Args],!,
  353.        atom_string(Functor,S_functor),
  354.        convert_to_strings(Args,S_args),
  355.        put_in_commas(S_args,S_args_with_commas),
  356.        concat(S_args_with_commas,S_arg_string),
  357.        concat([S_functor,$( $,S_arg_string,$ )$],String).
  358.  
  359. convert_to_string(_,$Undefined print string$).
  360.  
  361.  
  362.  
  363. /*************************************************************************/
  364. /*********** convert_to_strings : converts list of items to strings ******/
  365. /*************************************************************************/
  366. /*
  367.  
  368.     convert_to_strings( Termlist, Stringlist )
  369.  
  370.     converts a list of terms to a list of strings.
  371. */
  372. convert_to_strings([],[]).
  373. convert_to_strings([ H | T ],  [ H1 | T1 ]):-
  374.                convert_to_string(H , H1 ),
  375.                convert_to_strings(T , T1 ).
  376.  
  377.  
  378. /*************************************************************************/
  379. /********* put_in_separators : puts separators in a list  ****************/
  380. /*************************************************************************/
  381.  
  382. put_in_separators([],_,[]):-!.
  383. put_in_separators([H],_,[H]):-!.
  384. put_in_separators([H|T],Separator,[H,Separator|T1]):-
  385.     put_in_separators(T,Separator,T1).
  386.  
  387.  
  388. /*************************************************************************/
  389. /********* put_in_commas     : puts commas in a list  ********************/
  390. /*************************************************************************/
  391.  
  392. put_in_commas(List,Separated):-
  393.     put_in_separators(List,$, $,Separated).
  394.  
  395.  
  396. /*************************************************************************/
  397. /********* non_empty : true for non-empty sets ***************************/
  398. /*************************************************************************/
  399.  
  400. non_empty(  [_ | _ ]).
  401.  
  402.  
  403. /*************************************************************************/
  404. /********* delete_from_head : deletes string from head of string *********/
  405. /*************************************************************************/
  406.  
  407. delete_from_head( Main_string, Head_description, String_tail) :-
  408.             strip_off_extra_blanks( Main_string, Main_string2  ),
  409.              exists_at_head(  Main_string2, Head_description),
  410.              string_description_length( Head_description,
  411.                                         Head_lnth),
  412.              string_length( Main_string2, Main_lnth),
  413.              Tail_lnth is Main_lnth - Head_lnth,
  414.              Tail_lnth >= 0,
  415.              substring( Main_string2, Head_lnth, Tail_lnth, String_tail).
  416.  
  417. /*************************************************************************/
  418. /********* exists_at_head   : does a string exist at the head of a main***/
  419. /*****************************string *************************************/
  420. /*************************************************************************/
  421.  
  422. exists_at_head( Main_string, Pattern) :-
  423.           string( Pattern),
  424.           !,
  425.           string_search(1, Pattern, Main_string, 0).
  426.  
  427. exists_at_head( Main_string, Pattern) :-
  428.           atom( Pattern),
  429.           !,
  430.           atom_string( Pattern, S_pattern),
  431.           exists_at_head( Main_string, S_pattern) .
  432.  
  433. exists_at_head( Main_string, Pattern) :-
  434.           integer( Pattern),
  435.           !,
  436.           string_length( Main_string, Main_lnth),
  437.           Main_lnth >= Pattern.
  438.  
  439. /*************************************************************************/
  440. /***** delete_from_tail_if_there : deletes string from tail end of   *****/
  441. /*****                             string if the pattern is there    *****/
  442. /*************************************************************************/
  443.  
  444. delete_from_tail_if_there( Main_string,
  445.                            Tail_description,
  446.                            String_seg ) :-
  447.              delete_from_tail( Main_string,
  448.                                Tail_description,
  449.                                String_seg ),
  450.              !.
  451.  
  452. delete_from_tail_if_there( Main_string,
  453.                            _,
  454.                            Main_string   ) :- !.
  455.  
  456.  
  457. /*************************************************************************/
  458. /***** delete_from_head_if_there : deletes string from head end of   *****/
  459. /*****                             string if the pattern is there    *****/
  460. /*************************************************************************/
  461.  
  462. delete_from_head_if_there( Main_string,
  463.                            Head_description,
  464.                            String_seg ) :-
  465.              delete_from_head( Main_string,
  466.                                Head_description,
  467.                                String_seg ),
  468.              !.
  469.  
  470. delete_from_head_if_there( Main_string,
  471.                            _,
  472.                            Main_string   ) :- !.
  473.  
  474. /*************************************************************************/
  475. /********* delete_from_tail : deletes string from tail end of string *****/
  476. /*************************************************************************/
  477.  
  478. delete_from_tail( Main_string, Tail_description, String_seg ) :-
  479.             strip_off_extra_blanks( Main_string, Main_string2  ),
  480.              exists_at_tail( Main_string2, Tail_description),
  481.              string_description_length( Tail_description,
  482.                                         Tail_description_lnth),
  483.              string_length( Main_string2, Main_lnth),
  484.              Output_part_lnth is Main_lnth - Tail_description_lnth,
  485.              Output_part_lnth >= 0,
  486.              substring( Main_string2, 0,
  487.                         Output_part_lnth, String_seg ).
  488.  
  489. /*************************************************************************/
  490. /********* exists_at_tail   : does a string exist at the tail of a main***/
  491. /*****************************string *************************************/
  492. /*************************************************************************/
  493.  
  494.  
  495. exists_at_tail( Main_string, Pattern) :-
  496.           string( Pattern),
  497.           !,
  498.           string_description_length( Pattern,
  499.                                      Pattern_lnth),
  500.           string_length( Main_string, Main_lnth),
  501.           Output_start is Main_lnth - Pattern_lnth,
  502.           string_search(1, Pattern, Main_string, Output_start ).
  503.  
  504. exists_at_tail( Main_string, Pattern) :-
  505.           atom( Pattern),
  506.           !,
  507.           atom_string( Pattern, S_pattern),
  508.           exists_at_tail( Main_string, S_pattern) .
  509.  
  510. exists_at_tail( Main_string, Pattern) :-
  511.           integer( Pattern),
  512.           !,
  513.           string_length( Main_string, Main_lnth),
  514.           Main_lnth >= Pattern.
  515.  
  516.  
  517.  
  518. /*************************************************************************/
  519. /********* string_description_length : length of a string from a data ****/
  520. /************************************  item describing its length ********/
  521. /*************************************************************************/
  522.  
  523. string_description_length( Description,  Description) :-
  524.                        integer( Description ),
  525.                        !.
  526.  
  527. string_description_length( Description,  Lnth ) :-
  528.                        atom( Description),
  529.                        !,
  530.                        atom_string( Description, S_description),
  531.                        string_length( S_description, Lnth).
  532.  
  533. string_description_length( Description,  Lnth ) :-
  534.                        string( Description),
  535.                        !,
  536.                        string_length( Description, Lnth) .
  537.  
  538.  
  539.  
  540. /*************************************************************************/
  541. /********* once : does a goal only once **********************************/
  542. /*************************************************************************/
  543.  
  544. once(X) :- call(X), !.
  545.  
  546. /*************************************************************************/
  547. /********* write_error : writes error message ****************************/
  548. /*************************************************************************/
  549.  
  550.  
  551. write_error(  Error) :-
  552.     write_error( [],   Error).
  553.  
  554. write_error( Handles,   Error) :-
  555.       build_error_handle_list( Handles, Handles2),
  556.       !,
  557.       add_on_error_msg( Error, Errs2 )  ,
  558.       !,
  559.       trace_msg_hlpr2( Handles2, Errs2 ).
  560.  
  561. build_error_handle_list( Handles, Handles2) :-
  562.       is_list( Handles ),
  563.       !,
  564.       get_trace_handle(  LogHandle ),
  565.       !,
  566.       union( Handles, [ 1 , LogHandle ], Handles2).
  567.  
  568. build_error_handle_list( Handles, Handles2) :-
  569.       integer( Handles),
  570.       !,
  571.       build_error_handle_list( [Handles], Handles2).
  572.  
  573. build_error_handle_list( _ , Handles2) :-
  574.      build_error_handle_list( [] , Handles2) .
  575.  
  576.  
  577. add_on_error_msg( Error, Error_with_error_header)  :-
  578.         Error = [_ | _],
  579.         !,
  580.         error_header(  Header ),
  581.         Error_with_error_header = [ Header | Error].
  582.  
  583. add_on_error_msg( Error, Error_with_error_header)  :-
  584.         Error = [],
  585.         !,
  586.         error_header(  Header ),
  587.         Error_with_error_header = Header .
  588.  
  589. add_on_error_msg( Error, Error_with_error_header)  :-
  590.         error_header(  Header ),
  591.         Error_with_error_header = [ Header , Error].
  592.  
  593. error_header(   $ACHTUNG !! ACHTUNG !! -- ERROR : $).
  594.  
  595.  
  596. /*************************************************************************/
  597. /********* retractall : retracts all instances of a goal *****************/
  598. /*************************************************************************/
  599.  
  600. retractall( Name / Arity) :-
  601.         integer(Arity),
  602.         !,
  603.         functor(Term, Name, Arity),
  604.         retractall( Term).
  605. retractall( X) :-
  606.         retract(X),
  607.         fail.
  608. retractall( _).
  609.  
  610.  
  611. /*************************************************************************/
  612. /***************** append_to_end : adds item to end of list  *************/
  613. /*************************************************************************/
  614.  
  615.  
  616. append_to_end(X,Y,Z):-append1(X,Y,Z).
  617.                                        /* provide both easy to remember
  618.                                           and short  names */
  619. /* append1( Elt, Oldset, Newset ) adds Elt to end of Oldset and puts result
  620.    in Newset */
  621.  
  622. append1( Elt , [] , [ Elt ] ) :- !.   /* If Oldsdet is empty, the result
  623.                                          contains only the newly added
  624.                                          element. */
  625. append1( Elt, [ H | T ] , [ H | T1 ] ) :-
  626.                                        /*  Otherwise, make the head of   */
  627.                                        /*  the Oldset the head of the    */
  628.                                        /*  new list                      */
  629.  
  630.    append1( Elt , T , T1 ).            /*  and append the new element    */
  631.                                        /*  to the                        */
  632.                                        /*  tail of the current Oldset    */
  633.  
  634.  
  635. /*************************************************************************/
  636. /***************** list_length : length of a list  **********************/
  637. /*************************************************************************/
  638.  
  639. /* list_length( L, N ) finds the length of the list L and puts it into N */
  640. list_length( [], 0 ) :- !.             /*  empty list has length 0       */
  641. list_length( [ _ | T ], N ) :-         /*  For a non-empty list          */
  642.    list_length( T, M ), !,             /*  get length of tail            */
  643.    N is M+1.                           /*  and add 1 to it               */
  644.  
  645.  
  646. /*************************************************************************/
  647. /******* merge : merges two sorted lists into a single sorted list  ******/
  648. /*************************************************************************/
  649.  
  650. mergetrace(X) :- trace_message(  mergetrace, X).
  651. mergetrace  :- !
  652.                ,fail
  653.                .
  654.  
  655. /* merge(Sorted_list_1,Sorted_list_2,Order, Merged_list) merges
  656.    Sorted_list_1 and Sorted_list_2 into a single sorted list, Merged_list.
  657.    Order is an order relation such as =<.
  658. */
  659.  
  660. merge(Arg1,Arg2,_,_):-
  661.      mergetrace([$e merge: Arg1=$,Arg1,$Arg2=$,Arg2]),fail.
  662.  
  663. merge([],T,_,T):-!,                  /* merge of a list with [] does not */
  664.      mergetrace([$x merge 1=empty : $,T]).
  665.  
  666. merge(T,[],_,T):-!,                  /* alter the non-empty list         */
  667.      mergetrace([$x merge 2=empty : $,T]).
  668.  
  669. merge([H1|T1],[H2|T2],Order, [H1|Merged_list1]):-
  670.        Temp=..[Order,H1,H2],         /* If Order(H1,H2) is true          */
  671.        call(Temp),!,                 /* H1 is first in merged list       */
  672.        merge(T1,[H2|T2],Order,Merged_list1),
  673.      mergetrace([$x merge 1 first : $,[H1|Merged_list1]]).
  674.  
  675. merge(List1,[H2|T2],Order, [H2|Merged_list1]):-
  676.                                      /* Otherwise H2 is first in merged  */
  677.                                      /*  list                            */
  678.        merge(List1,T2,Order,Merged_list1),
  679.      mergetrace([$x merge 2 first : $,[H2|Merged_list1]]).
  680.  
  681. /* merge also exists in a simpler form that uses the standard order
  682.    relation =<                                                           */
  683.  
  684. merge([],T,T):-!.                    /* merge of a list with [] does not */
  685. merge(T,[],T):-!.                    /* alter the non-empty list         */
  686. merge([H1|T1],[H2|T2], [H1|Merged_list1]):-
  687. %  do_or_die([
  688.        H1 =< H2,!,                   /* If H1 =< H2 is true              */
  689.        merge(T1,[H2|T2],Merged_list1)
  690. %           ],mergetrace)
  691.         .
  692.                                      /* H1 is first in merged list       */
  693.  
  694. merge(List1,[H2|T2], [H2|Merged_list1]):-
  695.                                      /* Otherwise H2 is first in merged  */
  696.                                      /*  list                            */
  697.        merge(List1,T2,Merged_list1).
  698.  
  699. /*************************************************************************/
  700. /******* merge_sort : sorts a list using merge_sort algorithm ************/
  701. /*************************************************************************/
  702.  
  703. /*  merge_sort(Unsorted,Order,Sorted) sorts an unsorted list Unsorted using
  704.     the binary order relation Order, and puts the resulting list into
  705.     the variable Sorted.                                                 */
  706.  
  707.  
  708. merge_sort([],_,[]):-!.                /* empty list is sorted           */
  709. merge_sort([H],_,[H]):-!.              /* 1-element list is sorted       */
  710.  
  711. merge_sort(Unsorted,Order,Sorted):-
  712. % do_or_die([
  713.     partition_in_half(Unsorted, Half1, Half2),
  714.                                        /* partition list into halves     */
  715.     merge_sort(Half1,Order,Sorted_half1),  /* sort the halves            */
  716.     merge_sort(Half2,Order,Sorted_half2),  /* merge them together        */
  717.     merge(Sorted_half1,Sorted_half2,Order,Sorted)
  718. %           ],mergetrace)
  719.       .
  720.  
  721. /* This sort also comes in a form that uses the standard order relation
  722.    =< implicitly:                                                        */
  723.  
  724. merge_sort([],[]):-!.                  /* empty list is sorted           */
  725. merge_sort([H],[H]):-!.                /* 1-element list is sorted       */
  726. merge_sort(Unsorted,Sorted):-
  727. % do_or_die([
  728.     partition_in_half(Unsorted, Half1, Half2),
  729.                                        /* partition list into halves     */
  730.     merge_sort(Half1,Sorted_half1),    /* sort the halves                */
  731.     merge_sort(Half2,Sorted_half2),    /* merge them together            */
  732.     merge(Sorted_half1,Sorted_half2,Sorted)
  733. %           ],mergetrace)
  734.          .
  735.  
  736. /* both versions of merge use the following predicate that  partitions
  737.    a list in half                                                        */
  738. partition_in_half(Unsorted,Half1,Half2):-
  739.       partition_in_half1(Unsorted,[],[],1,Half1,Half2).
  740. partition_in_half1([],H1,H2,_,H1,H2):-!.
  741.                                        /* when input list is empty,      */
  742.                                        /* partition is finished          */
  743.  
  744. partition_in_half1([H|T],Sofar1,Sofar2,1,Half1,Half2):-!,
  745.        partition_in_half1(T,[H|Sofar1],Sofar2,2,Half1,Half2).
  746.                                        /* when last argument is 1, put   */
  747.                                        /* head of input into first half  */
  748.                                        /* put first of rest in 2nd half  */
  749. partition_in_half1([H|T],Sofar1,Sofar2,2,Half1,Half2):-!,
  750.        partition_in_half1(T,Sofar1,[H|Sofar2],1,Half1,Half2).
  751.                                        /* when last argument is 2, put   */
  752.                                        /* head of input into 2nd half    */
  753.                                        /* put first of rest in 1st half  */
  754.  
  755.  
  756.  
  757.  
  758.  
  759. %%%%%%%%%%%%%%%%%%% start of is_char char classificaiton preds %%%%%%%%%%%%
  760.  
  761. /*************************************************************************/
  762. /************** is_separator : succeeds if character is a separator  *****/
  763. /*************************************************************************/
  764.  
  765. is_separator( C ) :- C ==32.   % space
  766. is_separator( C ) :- C ==12.   % form feed
  767. is_separator( C ) :- C ==13.   % cr
  768. is_separator( C ) :- C ==10.   % lf
  769. is_separator( C ) :- C ==9 .   % tab
  770. is_separator( C ) :- C ==26.   % eof
  771.  
  772.  
  773. /*************************************************************************/
  774. /************** is_lc : succeeds if character is lower case  *************/
  775. /*************************************************************************/
  776.  
  777. is_lc( C ) :-
  778.     C >= `a, C =< `z.
  779.  
  780. /*************************************************************************/
  781. /************** is_uc : succeeds if character is upper case  *************/
  782. /*************************************************************************/
  783.  
  784. is_uc( C ) :-
  785.     C >= `A, C =< `Z.
  786.  
  787. /*************************************************************************/
  788. /************** is_digit : succeeds if character is a digit  *************/
  789. /*************************************************************************/
  790.  
  791. is_digit( C ) :-
  792.     C >= `0, C =< `9.
  793.  
  794. /*************************************************************************/
  795. /************** is_letter : succeeds if character is a letter ************/
  796. /*************************************************************************/
  797.  
  798. is_letter( C ) :- is_lc( C ) ,! ;
  799.                   is_uc( C ) ,! .
  800.  
  801.  
  802. /*************************************************************************/
  803. /************** is_alphanum : succeeds if character is alphanumeric  *****/
  804. /*************************************************************************/
  805.  
  806. is_alphanum( C ) :- is_lc( C ) ,! ;
  807.                     is_uc( C ) ,! ;
  808.                     is_digit( C ) ,! ;
  809.                     C == `_  ,! .
  810.  
  811.  
  812. /*************************************************************************/
  813. /************** separator   : true for separators ************************/
  814. /*************************************************************************/
  815.  
  816.  
  817.  
  818. separator( X ) --> [ X ],
  819.                    {is_separator(X)}.
  820.  
  821. %%%%%%%%%%%%%%%%%%%  end  of is_char char classificaiton preds %%%%%%%%%%%%
  822.  
  823.  
  824. /*************************************************************************/
  825. /************** write_error : write error message ************************/
  826. /*************************************************************************/
  827.  
  828. write_error(    List   )  :-
  829.     log_write($ERROR -- $),
  830.     write_list( List).
  831.  
  832. /*************************************************************************/
  833. /************** write_list  : write a list *******************************/
  834. /*************************************************************************/
  835.  
  836. write_list( [] )   :- log_nl, !.
  837. write_list( [H|T] ) :-
  838.     log_write(H), log_tab(1),
  839.     write_list(T).
  840.  
  841.  
  842.  
  843.                        % eof
  844.